Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/FORM_UTL/MINMAX/MINMAX.ZIP/MinMax.pas

Pascal/Delphi Source File | 1996-08-30 | 10.8 KB | 292 lines

{ -------------------------------------------------------------------------------------}
{ A "MinMax Form Sizer" component for Delphi32.                                        }
{ Copyright 1996, Patrick Brisacier.  All Rights Reserved.                             }
{ This component can be freely used and distributed in commercial and private          }
{ environments, provided this notice is not modified in any way.                       }
{ -------------------------------------------------------------------------------------}
{ Feel free to contact us if you have any questions, comments or suggestions at        }
{ [e-mail] (Patrick Brisacier)                                        }
{ -------------------------------------------------------------------------------------}
{ Thanks to Brad Stowers ([e-mail]) for his help.                            }
{ -------------------------------------------------------------------------------------}
{ Date last modified:  08/20/96                                                        }
{ -------------------------------------------------------------------------------------}

{ -------------------------------------------------------------------------------------}
{ TMinMax v1.01                                                                        }
{ -------------------------------------------------------------------------------------}
{ Description:                                                                         }
{   A component that allows you to minimize and maximize forms size. You can also      }
{   allow user to resize or not a running form.                                        }
{ Properties:                                                                          }
{  property MaxSize: TMinMaxPoint;                                                     }
{  property MaxPosition: TMinMaxPoint;                                                 }
{  property MinTrackSize: TMinMaxPoint;                                                }
{  property MaxTrackSize: TMinMaxPoint;                                                }
{  property Options: TMinMaxOptions;                                                   }
{                                                                                      }
{ See example contained in example.zip file for more details.                          }
{ -------------------------------------------------------------------------------------}
{ Revision History:                                                                    }
{ 1.00:  + Initial release                                                             }
{ 1.01:  + Problem corrected in the HookWndProc by Brad Stowers ([e-mail])   }
{ -------------------------------------------------------------------------------------}

unit MinMax;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DsgnIntf, TypInfo, ExtCtrls;

type
  TMinMaxOption = (opAllowResize, opMaxPosition, opMaxSize, opMaxTrackSize, opMinTrackSize);
  TMinMaxOptions = set of TMinMaxOption;

  TMinMaxPoint = class(TPersistent)
  private
    FX, FY: LongInt;
  public
    function GetTPoint: TPoint;
    procedure Assign(Source: TPersistent); override;
  published
    property X: LongInt
             read FX write FX;
    property Y: LongInt
             read FY write FY;
  end;

  TMinMax = class(TCustomControl)
  private
    { DΘclarations privΘes }
    FMaxSize: TMinMaxPoint;
    FMaxPosition: TMinMaxPoint;
    FMinTrackSize: TMinMaxPoint;
    FMaxTrackSize: TMinMaxPoint;
    FOptions: TMinMaxOptions;
    OldWndProc: TFarProc;
    NewWndProc: Pointer;
    procedure HookParent;
    procedure UnhookParent;
    procedure HookWndProc(var Message: TMessage);
  protected
    { DΘclarations protΘgΘes }
    procedure Paint; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure Loaded; override;
    procedure SetParent(Value: TWinControl); override;
  public
    { DΘclarations publiques }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { DΘclarations publiΘes }
    property MaxSize: TMinMaxPoint
             read FMaxSize write FMaxSize;
    property MaxPosition: TMinMaxPoint
             read FMaxPosition write FMaxPosition;
    property MinTrackSize: TMinMaxPoint
             read FMinTrackSize write FMinTrackSize;
    property MaxTrackSize: TMinMaxPoint
             read FMaxTrackSize write FMaxTrackSize;
    property Options: TMinMaxOptions
             read FOptions write FOptions;
  end;

procedure Register;

implementation

var
  aBitmap: TBitmap;
  Loaded: Boolean;

procedure LoadBitmap;
begin
  if Loaded then exit;
  Loaded := True;
  if aBitmap = nil then aBitmap := TBitmap.Create;
  try
    aBitmap.LoadFromResourceName(HInstance, 'TMINMAX');
  except
    on E:Exception do ShowMessage(E.Message);
  end;
end;

function TMinMaxPoint.GetTPoint: TPoint;
begin
  Result := Point(FX, FY);
end;

procedure TMinMaxPoint.Assign(Source: TPersistent);
begin
  FX := (Source as TMinMaxPoint).X;
  FY := (Source as TMinMaxPoint).Y;
end;


constructor TMinMax.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { set default value }
  FOptions := [opAllowResize, opMaxSize, opMaxPosition, opMinTrackSize, opMaxTrackSize];
  { Initialize variables }
  NewWndProc := nil;
  OldWndProc := nil;
  FMaxSize := TMinMaxPoint.Create;
  FMaxPosition := TMinMaxPoint.Create;
  FMinTrackSize := TMinMaxPoint.Create;
  FMaxTrackSize := TMinMaxPoint.Create;
end;

destructor TMinMax.Destroy;
begin
  { Always make sure that the hook is removed. }
  UnhookParent;
  FMaxSize.Free;
  FMaxPosition.Free;
  FMinTrackSize.Free;
  FMaxTrackSize.Free;
  inherited Destroy;
end;

procedure TMinMax.Paint;
var
  MonRect, BitmapRect: TRect;
begin
  if csDesigning in ComponentState then begin
    MonRect := Rect(0,0,Width,Height);
    Frame3D(Canvas, MonRect, clBtnHighlight, clBlack, 1);
    Frame3D(Canvas, MonRect, clBtnFace, clBtnShadow, 1);
    Canvas.Brush.color := clBtnFace;
    Canvas.FillRect(MonRect);
    BitmapRect := Bounds(0,0,aBitmap.Width, aBitmap.Height);
    MonRect := Bounds((Width - aBitmap.Width) div 2,
                      (Height - aBitmap.Height) div 2,
                      aBitmap.Width, aBitmap.Height);
    Canvas.BrushCopy(MonRect, aBitmap, BitmapRect, aBitmap.TransparentColor);
  end;
  inherited Paint;
end;

procedure TMinMax.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if csDesigning in ComponentState then
  begin
    AWidth := 28;
    AHeight := 28;
  end;
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

procedure TMinMax.Loaded;
begin
  if csDesigning in ComponentState then LoadBitmap
  else Visible := False;
  inherited Loaded;
end;

{ This procedure is used to get the parent's window procedure, save it,      }
{ and replace it with our own.  This allows see all of the parent's messages }
{ before it does.                                                            }
procedure TMinMax.HookParent;
begin
  { If there is no parent, we can't hook it. }
  if Parent = NIL then exit;
  { Get the old window procedure via API call and store it. }
  OldWndProc := TFarProc(GetWindowLong(Parent.Handle, GWL_WNDPROC));
  { Convert our object method into something Windows knows how to call }
  NewWndProc := MakeObjectInstance(HookWndProc);
  { Install it as the new Parent window procedure }
  SetWindowLong(Parent.Handle, GWL_WNDPROC, LongInt(NewWndProc));
end;

{ Remove our window function and reinstall the original. }
procedure TMinMax.UnhookParent;
begin
  { We must have a parent, and we must have already hooked it. }
  if (Parent <> NIL) and assigned(OldWndProc) then
    { Set back to original window procedure }
    SetWindowLong(Parent.Handle, GWL_WNDPROC, LongInt(OldWndProc));
  { If we have created a window procedure via MakeObjectInstance, }
  { it must be disposed of.                                       }
  if assigned(NewWndProc) then
    FreeObjectInstance(NewWndProc);
  { Reset variables to NIL }
  NewWndProc := NIL;
  OldWndProc := NIL;
end;

{ The window procedure that is installed into our parent. }
procedure TMinMax.HookWndProc(var Message: TMessage);
var
  Test: LResult;
begin
  { If there's no parent, something has really gone wrong. }
  if Parent = NIL then exit;
  with Message do begin
    { If Parent gets a WM_SIZE message, it has been resized }
    if (Msg = WM_GETMINMAXINFO) then begin
      if opMaxSize in FOptions then
        PMinMaxInfo(LParam)^.ptMaxSize := FMaxSize.GetTPoint;
      if opMaxPosition in FOptions then
        PMinMaxInfo(LParam)^.ptMaxPosition := FMaxPosition.GetTPoint;
      if opAllowResize in FOptions then begin
        if opMinTrackSize in FOptions then
          PMinMaxInfo(LParam)^.ptMinTrackSize := FMinTrackSize.GetTPoint;
        if opMaxTrackSize in FOptions then
          PMinMaxInfo(LParam)^.ptMaxTrackSize := FMaxTrackSize.GetTPoint;
      end
      else begin
        PMinMaxInfo(LParam)^.ptMinTrackSize := Point(Parent.Width,Parent.Height);
        PMinMaxInfo(LParam)^.ptMaxTrackSize := Point(Parent.Width,Parent.Height);
      end;
    end;
    { message WM_INITMENUPOPUP }
    if (Msg = WM_INITMENUPOPUP) and not (opAllowResize in Options) then
    begin
      if TWMInitMenuPopup(Message).SystemMenu then
         EnableMenuItem(TWMInitMenuPopup(Message).MenuPopup, SC_SIZE,MF_BYCOMMAND or MF_GRAYED);
    end;
    { ALWAYS call the old window procedure so the parent can process its   }
    { messages.  Thanks to Gary Frerking for pointing me at CallWindowProc }
    { I was trying to call the function directly, which died horribly.     }
    Result := CallWindowProc(OldWndProc, Parent.Handle, Msg, wParam, lParam);

    // From Brad:
    //   WM_NCHITTEST needs to be processed after calling the old window's proc.
    { message WM_NCHitTest }
    if (Msg = WM_NCHitTest) and not (opAllowResize in Options) then begin
      if Result in [HTLEFT, HTRIGHT, HTBOTTOM, HTBOTTOMRIGHT,
            HTBOTTOMLEFT, HTTOP, HTTOPRIGHT, HTTOPLEFT] then
        Result:= HTNOWHERE;
    end;
  end;
end;

{ A Parent has been assigned or changed.  Unhook old parent and install }
{ hook in new parent.                                                   }
procedure TMinMax.SetParent(Value: TWinControl);
begin
  { UnhookParent knows if the current parent has been hooked or not }
  UnhookParent;
  { Set Parent to the new value }
  inherited SetParent(Value);
  { Hook the new parent's window procedure }
  HookParent;
end;


procedure Register;
begin
  RegisterComponents('SystΦme', [TMinMax]);
end;

initialization
  aBitmap := nil;
  Loaded := False;
finalization
  aBitmap.Free;
end.